home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / ada / gnat1792.zip / gnat179b / t-adainc / a-caldel.adb < prev    next >
Text File  |  1994-05-19  |  8KB  |  245 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                 GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS               --
  4. --                                                                          --
  5. --                   A D A . C A L E N D A R . D E L A Y S                  --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.4 $                             --
  10. --                                                                          --
  11. --           Copyright (c) 1991,1992,1993, FSU, All Rights Reserved         --
  12. --                                                                          --
  13. --  GNARL is free software; you can redistribute it and/or modify it  under --
  14. --  terms  of  the  GNU  Library General Public License as published by the --
  15. --  Free Software Foundation; either version 2, or  (at  your  option)  any --
  16. --  later  version.   GNARL is distributed in the hope that it will be use- --
  17. --  ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of --
  18. --  MERCHANTABILITY  or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. --  eral Library Public License for more details.  You should have received --
  20. --  a  copy of the GNU Library General Public License along with GNARL; see --
  21. --  file COPYING. If not, write to the Free Software Foundation,  675  Mass --
  22. --  Ave, Cambridge, MA 02139, USA.                                          --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Compiler_Exceptions;
  27. --  Uses, function Current_Exceptions
  28.  
  29. with System.Task_Timer_Service;
  30. --  Uses, object Objects
  31. --        procedure Service_Entries
  32.  
  33. with Unchecked_Conversion;
  34.  
  35. package body Ada.Calendar.Delays is
  36.  
  37.    use System.Tasking.Protected_Objects;
  38.    use Tasking;
  39.  
  40.    package Timer renames System.Task_Timer_Service.Timer;
  41.  
  42.    function To_Access is new Unchecked_Conversion (
  43.          System.Address,
  44.          Protection_Access);
  45.  
  46.    ------------------
  47.    -- Delay_Object --
  48.    ------------------
  49.  
  50.    package body Delay_Object is
  51.  
  52.       ---------------------
  53.       -- Service_Entries --
  54.       ---------------------
  55.  
  56.       procedure Service_Entries (Pending_Serviced : out Boolean) is
  57.          P : System.Address;
  58.  
  59.          subtype PO_Entry_Index is Protected_Entry_Index
  60.                range Null_Protected_Entry .. 1;
  61.  
  62.          Barriers : Tasking.Barrier_Vector (1 .. 1) := (others => true);
  63.          --  no barriers. always true barrier
  64.  
  65.          E : PO_Entry_Index;
  66.  
  67.          PS : Boolean;
  68.  
  69.          Cumulative_PS : Boolean := False;
  70.  
  71.       begin
  72.          loop
  73.             --  Get the next queued entry or the pending call (if no
  74.             --  barriers are true).
  75.  
  76.             Tasking.Protected_Objects.Next_Entry_Call
  77.               (To_Access (Object'Address), Barriers, P, E);
  78.  
  79.             begin
  80.                case E is
  81.  
  82.                   --  No pending call to serve
  83.  
  84.                   when Null_Protected_Entry =>
  85.                      exit;
  86.  
  87.                   when 1 =>
  88.  
  89.                      --  Lock the object before requeing
  90.  
  91.                      Tasking.Protected_Objects.Lock
  92.                        (To_Access (Timer.Object'Address));
  93.  
  94.                      begin
  95.                         Requeue_Protected_Entry (
  96.                           Object => To_Access (Object'Address),
  97.                           New_Object => To_Access (Timer.Object'Address),
  98.                           E => 2,
  99.                           With_Abort => True);
  100.                         Timer.Service_Entries (PS);
  101.                         Tasking.Protected_Objects.Unlock
  102.                           (To_Access (Timer.Object'Address));
  103.  
  104.                         --  Requeue on the timer for the service.
  105.                         --  Parameter is passed along as
  106.                         --  Object.Call_In_Progress.Param
  107.  
  108.                      --  Following code temporarily commented out ???
  109.  
  110.                      --  exception
  111.                      --     when others =>
  112.                      --        Timer.Service_Entries;
  113.                      --        raise;
  114.  
  115.                      --  Neither Requeue nor Service_Entries should raise
  116.                      --  an exception; the exception should be saved.
  117.  
  118.                      end;
  119.  
  120.                end case;
  121.  
  122.             exception
  123.                when others =>
  124.                   Tasking.Protected_Objects.Exceptional_Complete_Entry_Body (
  125.                     Object => To_Access (Object'Address),
  126.                     Ex => System.Compiler_Exceptions.Current_Exception,
  127.                     Pending_Serviced => PS);
  128.             end;
  129.  
  130.             Cumulative_PS := Cumulative_PS or PS;
  131.          end loop;
  132.  
  133.          Pending_Serviced := Cumulative_PS;
  134.       end Service_Entries;
  135.  
  136.    --  Initialization for package body Delay_Object
  137.  
  138.    begin
  139.       Initialize_Protection (
  140.         To_Access (Object'Address),
  141.         Tasking.Unspecified_Priority);
  142.  
  143.    end Delay_Object;
  144.  
  145.    ------------------------
  146.    -- Delay_Until_Object --
  147.    ------------------------
  148.  
  149.    package body Delay_Until_Object is
  150.  
  151.       ---------------------
  152.       -- Service_Entries --
  153.       ---------------------
  154.  
  155.       procedure Service_Entries (Pending_Serviced : out Boolean) is
  156.  
  157.          P : System.Address;
  158.  
  159.          subtype PO_Entry_Index is Protected_Entry_Index
  160.            range Null_Protected_Entry .. 1;
  161.  
  162.          Barriers : Tasking.Barrier_Vector (1 .. 1) := (others => true);
  163.          --  No barriers. always true barrier
  164.  
  165.          E : PO_Entry_Index;
  166.  
  167.          PS : Boolean;
  168.  
  169.          Cumulative_PS : Boolean := False;
  170.  
  171.       begin
  172.          loop
  173.             --  Get the next queued entry or the pending call
  174.             --  (if no barriers are true)
  175.  
  176.             Tasking.Protected_Objects.Next_Entry_Call
  177.               (To_Access (Object'Address), Barriers, P, E);
  178.  
  179.             begin
  180.                case E is
  181.  
  182.                   --  No pending call to serve
  183.  
  184.  
  185.                   when Null_Protected_Entry =>
  186.                      exit;
  187.  
  188.                   when 1 =>
  189.  
  190.                      --  Lock the object before requeueing
  191.  
  192.                      Tasking.Protected_Objects.Lock
  193.                        (To_Access (Timer.Object'Address));
  194.  
  195.                      begin
  196.                         Requeue_Protected_Entry (
  197.                           Object => To_Access (Object'Address),
  198.                           New_Object => To_Access (Timer.Object'Address),
  199.                           E => 4,
  200.                           With_Abort => true);
  201.                         Timer.Service_Entries (PS);
  202.                         Tasking.Protected_Objects.Unlock
  203.                           (To_Access (Timer.Object'Address));
  204.  
  205.                         --  Requeue on the timer for the service.
  206.                         --  Parameter is passed along as
  207.                         --  Object.Call_In_Progress.Param
  208.  
  209.                         --  Following code temporarily commented out ???
  210.  
  211.    --                   --  exception
  212.    --                   --     when others =>
  213.    --                   --        Timer.Service_Entries;
  214.    --                   --        raise;
  215.                      end;
  216.  
  217.                   --  Neither Requeue nor Service_Entries should raise
  218.                   --  an exception; the exception should be saved.
  219.  
  220.                end case;
  221.  
  222.             exception
  223.                when others =>
  224.                   Tasking.Protected_Objects.Exceptional_Complete_Entry_Body (
  225.                     Object => To_Access (Object'Address),
  226.                     Ex => System.Compiler_Exceptions.Current_Exception,
  227.                     Pending_Serviced => PS);
  228.             end;
  229.  
  230.             Cumulative_PS := Cumulative_PS or PS;
  231.          end loop;
  232.  
  233.          Pending_Serviced := Cumulative_PS;
  234.       end Service_Entries;
  235.  
  236.    --  Initialization for package body Delay_Until_Object
  237.  
  238.    begin
  239.